;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2020, 2021 Maxime Devos <maximedevos@telenet.be>
;;
;;   scheme-GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   scheme-GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; Synopsis: a wrapper around (gnu gnunet netstruct procedural) performing
;; some checks and inlining during expansion.
(define-library (gnu gnunet netstruct syntactic)
  (export sizeof offsetof select read% set%!
	  structure/packed define-type)
  (import (rnrs base)
	  (rnrs control)
	  (only (rnrs exceptions)
		raise)
	  (only (rnrs bytevectors) endianness)
	  (rnrs syntax-case)
	  (only (guile)
		display
		newline
		compose
		call-with-prompt abort-to-prompt make-prompt-tag
		resolve-module module-ref)
	  (only (system syntax) syntax-local-binding)
	  (gnu gnunet utils bv-slice)
	  (only (srfi srfi-1) span assq filter-map concatenate)
	  (only (srfi srfi-2) and-let*)
	  (only (srfi srfi-8) receive)
	  (only (srfi srfi-16) case-lambda)
	  (only (srfi srfi-26) cute)
	  (only (srfi srfi-88) keyword?)
	  (only (ice-9 control) let/ec)
	  (prefix (gnu gnunet netstruct procedural)
		  p@))
  (begin
    
    (define (syntax->attributes s whom)
      ;; whom: one of field, structure/packed
      ;; result: some keyword arguments (KEYWORD . VALUE-SYNTAX)
      ;;  and some other objects (e.g. FIELD . FIELD-SYNTAX)
      (map (lambda (s)
	     (syntax-case s (synopsis documentation properties field)
	       ((synopsis a) (cons #:synopsis #'a))
	       ((documentation a) (cons #:documentation #'a))
	       ((properties a) (cons #:properties #'a))
	       ((field (name type) . attr) (and (eq? whom 'structure/packed)
						(symbol? (syntax->datum #'name)))
		`(field ,#''name ,#'type .
			,(syntax->attributes #'attr 'field)))))
	   (syntax-list->list-syntax s)))

    (define (attributes->fields-syntax attr)
      (define (field-attribute->syntax f)
	(and (eq? (car f) 'field)
	     #`(p@make-field #,(list-ref f 1)
			     #,(list-ref f 2)
			     . #,(attributes->keyword-arguments (cdddr f)))))
      (filter-map field-attribute->syntax attr))

    (define (attributes->keyword-arguments attr)
      (define (keyword-attribute->list attr)
	(and (keyword? (car attr))
	     `(,(car attr) ,(cdr attr))))
      (concatenate (filter-map keyword-attribute->list attr)))

    (define (syntax-cdr s)
      (syntax-case s ()
	((_ . rest) #'rest)))

    (define-syntax structure/packed
      (lambda (s)
	(let* ((attr (syntax->attributes
		      (syntax-cdr s)
		      'structure/packed)))
	  #`(p@make-netstructure
	     (vector #,@(attributes->fields-syntax attr))
	     #,@(attributes->keyword-arguments attr)))))

    (define-syntax define-type
      (syntax-rules ()
	((_ name value)
	 (define name value))))
    

    ;; Analysis of syntax into dynamic and static parts
    ;;
    ;;  (static . _): _ is self-evaluating
    ;;  (dynamic . _): _ must be computed at runtime
    ;;  (dynamic-tail . _): the list _ must be computed at runtime
    ;;   (if this exists, this must be the last component)
    (define (decode-netstruct s type-syntax)
      "Try to determine the @code{<network-structure>} referred
to by @var{type-syntax}.  If that fails, just return the syntax
@var{type-syntax} itself."
      (let/ec dynamic
	(unless (identifier? type-syntax)
	  (dynamic #'type-syntax))
	(receive (binding-type val) (syntax-local-binding type-syntax)
	  (unless (eq? binding-type 'global)
	    (dynamic #'type-syntax))
	  (let ((mod (resolve-module (cdr val) #:ensure #f)))
	    (unless mod
	      (dynamic #'type-syntax))
	    (let ((value (module-ref mod (car val))))
	      (unless (p@netstruct? value)
		(syntax-violation 'decode-netstruct
				  "the subform must refer to a netstruct"
				  s type-syntax))
	      value)))))

    (define (syntax-list->list-syntax s)
      (syntax-case s ()
	(() '())
	((x . r) (cons #'x (syntax-list->list-syntax #'r)))))

    (define (decode-fields fields)
      "Deterine which parts of @var{fields} are variable and which are
fixed.  Currently, @code{quote}, @code{quasiquote}, @code{unquote}
and @code{list} are recognised."
      (syntax-case fields ()
	((q (x ...))
	 (cond ((free-identifier=? #'q #'quote)
		(apply decode-fields/quote
		       (syntax-list->list-syntax #'(x ...))))
	       ((free-identifier=? #'q #'quasiquote)
		(apply decode-fields/quasiquote
		       (syntax-list->list-syntax #'(x ...))))
	       (#t `((dynamic-tail . ,fields)))))
	((l x ...)
	 (cond ((free-identifier=? #'l #'list)
		(apply decode-fields/list
		       (syntax-list->list-syntax #'(x ...))))
	       (#t `((dynamic-tail . ,fields)))))
	(x `((dynamic-tail . ,fields)))))

    (define (decode-fields/quote . components)
      (map (lambda (s) (cons 'static (syntax->datum s)))
	   components))

    (define (decode-fields/quasiquote . components)
      (map (lambda (s)
	     (syntax-case s ()
	       ((u x) (free-identifier=? #'u #'unquote)
		(let ((d (syntax->datum #'x)))
		  (if (self-evaluating? d)
		      (cons 'static d)
		      (cons 'dynamic #'x))))
	       (y (cons 'static (syntax->datum s)))))
	   components))

    (define (decode-fields/list . components)
      (map (lambda (s)
	     (let ((d (syntax->datum s)))
	       (if (self-evaluating? d)
		   (cons 'static d)
		   (cons 'dynamic s))))
	   components))

    (define (self-evaluating? datum)
      ;; booleans, keywords, etc. can be added as-needed
      (or (number? datum)
	  (string? datum)
	  (vector? datum)
	  (char? datum)))

    

    ;; Partial evaluation
    (define (verify-bounds/syntax i length)
      #`(unless (and (integer? #,i)
		     (exact? #,i)
		     (<= 0 #,i)
		     (< #,i length))
	  (raise (%out-of-bounds-cond 'offset+sizeof/partial-tree))))

    (define (offset+sizeof/partial-tree s ns/syntax ns fields)
      "Return five values: a syntax that computes the offset,
a syntax that computes the size, a syntax performing bounds
checks that were eliminated by the partial evaluation,
whether @var{ns/syntax} was used, and the network structure
pointed at by @var{fields} (if known, @code{#f} otherwise).

XXX some side-effects are performed both in offset and size
syntax"
      (define (static? field)
	(eq? (car field) 'static))
      (receive (static partially-dynamic)
	  (span static? fields)
	;; Remove the @code{static} symbol from the car,
	;; leaving only the field names in @var{static}.
	(let* ((static* (map cdr fields))
	       (off (p@offsetof ns static*))
	       (p (p@part ns static*)))
	  (if (null? partially-dynamic)
	      (values (datum->syntax s off)
		      (datum->syntax s (p@sizeof ns static*))
		      #'#t
		      #f
		      ns)
	      (case (caar partially-dynamic)
		((dynamic-tail) ;; XXX untested
		 (values #`(+ #,(datum->syntax s off)
			      (p@offsetof
			       (p@part #,ns/syntax
				       #,(cdar partially-dynamic))))
			 #`(p@sizeof #,ns/syntax #,(cdar partially-dynamic))
			 #'#t
			 #t
			 #f))
		((dynamic)
		 (receive (off/tail size/tail check/tail used/tail
				    innermost)
		     (offset+sizeof/partial-tree s 'xxx-unsupported p
						 (cdr partially-dynamic))
		   (cond ((p@netarray? p)
			  (let* ((element-type (p@netarray-type p))
				 (element-size (p@sizeof element-type '()))
				 (length (p@netarray-length p))
				 (i (cdar partially-dynamic)))
			    (values #`(+ #,(datum->syntax s off)
					 (* #,(datum->syntax s element-size) #,i)
					 #,off/tail)
				    size/tail
				    #`(begin #,(verify-bounds/syntax i length)
					     #,check/tail)
				    used/tail
				    innermost)))
			 (#t (raise 'XXX-unsupported))))))))))

    (define (call-with-variable-binder proc)
      "Call @var{proc} with a procedure @var{make-variable!} and
@var{done} in a dynamic environment where @var{make-variable!}
introduces a variable binding, returning a variable and @var{done}
returns the first argument to @code{let}.

@var{done} can only be used once.

XXX describe this better."
      (let ((t (make-prompt-tag)))
	(define (make-variable! v)
	  (abort-to-prompt t 'v v))
	(define (done)
	  (abort-to-prompt t))
	(let loop ((bindings #'())
		   (next (lambda () (proc make-variable! done))))
	  (call-with-prompt t
	    next
	    (case-lambda
	      ((done)
	       (done bindings))
	      ((use-variable unused value)
	       (let* ((vs (generate-temporaries '(1)))
		      (v (car vs)))
		 (loop #`((#,v #,value) . #,bindings)
		       (lambda () (use-variable v))))))))))

    (define (bind-variables fields)
      "Replace variable parts in @var{fields} by variables,
to avoid performing side-effects twice.  Two values are
returned: the first argument to the new @code{let} form,
and the adjusted @var{fields}."
      (call-with-variable-binder
       (lambda (make-variable! done)
	 (define (adjust-field field)
	   (case (car field)
	     ((static) field)
	     ((dynamic) (cons 'dynamic (make-variable! (cdr field))))
	     ((dynamic-tail)
	      (cons 'dynamic-tail (make-variable! (cdr field))))))
	 (let ((fields* (map adjust-field fields)))
	   (values (done) fields*)))))

    

    ;; Various syntax
    (define (any s type fields proc)
      (let* ((ns (decode-netstruct s type))
	     (fi (decode-fields fields)))
	(let*-values
	    (((bindings fields*) (bind-variables fi))
	     ((offset size index-check used-ns innermost-ns)
	      (offset+sizeof/partial-tree s #'type-saved ns fields*)))
	  #`(let (#,@(if used-ns
			`(,#`(type-saved #,type))
			'())
		  #,@bindings)
	      #,index-check
	      #,(proc offset size)))))

    (define-syntax sizeof
      (lambda (s)
	"A syntax for computing the size of a network structure
(or one of its fields) at compile time where possible."
	(syntax-case s ()
	  ((_ type fields)
	   (any s #'type #'fields
		(lambda (offset size) size))))))

    (define-syntax offsetof
      (lambda (s)
	"A syntax for computing the offset of a field in a network
structure at compile time where possible."
	(syntax-case s ()
	  ((_ type fields)
	   (any s #'type #'fields
		(lambda (offset size) offset))))))

    (define (any/slice s type fields slice proc)
      (let* ((ns (decode-netstruct s type))
	     (fi (decode-fields fields)))
	(let*-values
	    (((bindings fields*) (bind-variables fi))
	     ((offset/field size/field index-check used-ns innermost-ns)
	      (offset+sizeof/partial-tree s #'type-saved ns fields*))
	     ((_/1 size/all _/2 used-ns/all _/3)
	      (offset+sizeof/partial-tree s #'type-saved ns '())))
	  #`(let ((sl #,slice)
		  #,@(if (or used-ns used-ns/all)
			 `(,#`(type-saved #,type))
			 '())
		  #,@bindings)
	      #,index-check
	      (let ((expected-length #,size/all)
		    (found-length (slice-length sl)))
		(unless (= found-length expected-length)
		       (raise
			(p@%select-length-cond expected-length found-length)))
		(let ((sl:part (slice-slice sl #,offset/field #,size/field)))
		  #,(proc #'sl:part innermost-ns)))))))

    (define-syntax select
      (lambda (s)
	"A syntax for selecting a part of a bytevector slice,
with some inlining where possible."
	(syntax-case s ()
	  ((_ type fields slice)
	   (any/slice s #'type #'fields #'slice
		      (lambda (sl ns) sl))))))

    
    ;; Reader and setter

    (define-syntax unsigned-N-bytes-syntax
      (syntax-rules ()
	((_ ((N uN/big uN/little)
	     (slice-N-ref slice-N-set!))
	    ...)
	 (lambda (ns)
	   (and-let* ((_1 (p@netprimitive? ns))
		      (p (p@properties ns))
		      (t (assq 'integer-type p))
		      (_2 (eq? (cdr t) 'unsigned))
		      (e (assq 'endianness p)))
	     (let ((endian (cdr e))
		   (size (p@sizeof ns '())))
	       (case size
		 ((N)
		  (case endian
		    ((big)
		     (values #`(cute slice-N-ref <> 0 (endianness big))
			     #`(cute slice-N-set! <> 0 (endianness big))))
		    ((little)
		     (values #`(cute slice-N-ref <> 0 (endianness little))
			     #`(cute slice-N-set! <> 0 (endianness little))))
		    (else #f)))
		 ...
		 (else #f))))))))

    (define (reader/writer-syntax ns)
      (if (eq? ns p@u8)
	  (values #'(cute slice-u8-ref <> 0)
		  #'(cute slice-u8-set! <> 0))
	  ((unsigned-N-bytes-syntax
	    ((2 u16/big u16/little) (slice-u16-ref slice-u16-set!))
	    ((4 u32/big u32/little) (slice-u32-ref slice-u32-set!))
	    ((8 u64/big u64/little) (slice-u64-ref slice-u64-set!)))
	   ns)))

    (define (reader-syntax ns)
      (call-with-values (lambda () (reader/writer-syntax ns))
	(case-lambda
	  ((unused) #f)
	  ((reader writer) reader))))

    (define (writer-syntax ns)
      (call-with-values (lambda () (reader/writer-syntax ns))
	(case-lambda
	  ((unused) #f)
	  ((reader writer) writer))))

    (define-syntax read%
      (lambda (s)
	"A syntax for reading a part of a bytevector slice,
with some inlining where possible."
	(syntax-case s ()
	  ((_ type fields slice)
	   (let/ec not-inlinable
	     (any/slice s #'type #'fields #'slice
			(lambda (sl ns)
			  #`(#,(or (reader-syntax ns)
				   (not-inlinable
				    #'(p@read% type fields slice)))
			     #,sl))))))))
    (define-syntax set%!
      (lambda (s)
	"A syntax for writing to a part of a bytevector slice,
with some inlining where possible."
	(syntax-case s ()
	  ((_ type fields slice value)
	   (let/ec not-inlinable
	     #`(let ((v value))
		 #,(any/slice
		    s #'type #'fields #'slice
		    (lambda (sl ns)
		      #`(#,(or (writer-syntax ns)
			       (not-inlinable
				#'(p@set%! type fields slice value)))
			 #,sl)))))))))))
